perm filename BUNDLE.OLD[CAR,BGB] blob
sn#019086 filedate 1973-01-06 generic text, type T, neo UTF8
00100 SUBR(BUNDLE)LEVEL-------------------------------------------------
00200 BEGIN BUNDLE;MAKE ARC RADIAL POINTERS FROM THIS LEVEL TO BELOW.
00300 ;BGB - 28 DECEMBER 1972.
00400
00500 ;A SINGLE VIC RADIAL INDICATES PARALLEL COINCIDANT VIC.
00600 ;AN ARC INDICATES A SET OF NEARLY COLINEAR VIC.
00700 SKIPN FLGKRK↔POP1J
00800 LAC 1,ARG1 ;LEVEL
00900 HEAD 1,1 ;POLYGON.
01000 DAC 1,PG0# ;FIRST POLYGON.
01100
01200 ;POLYGON PROCESSING LOOP.
01300 L1: DAC 1,IPG#↔HEAD 2,1↔DAC 2,IV1#↔DAC 2,IV0
01400 EXO 1,1↔ HEAD 2,1↔DAC 2,OV1#↔DAC 2,OV0
01500
01600 ;VIC PROCCESSING LOOP.
01700 L2: CALL(NEXRAD,OV1,IV1)↔GO L3
01800 SETZM FLAG# ;DETECTED END OF POLYGON.
01900 DAC 4,ARCO#↔DAC 5,ARCI#
02000
02100 ;SPECIAL STEP & STOP CASES INNER.
02200 ARC 0,2↔CAMN 0,ARCO
02300 CCW 2,2↔DAC 2,OV1
02400 CAMN 2,OV0↔SETOM FLAG
02500
02600 ;SPECIAL STEP & STOP CASES OUTER.
02700 ARC 0,3↔CAMN 0,ARCI
02800 CCW 3,3↔DAC 3,IV1
02900 CAMN 3,IV0↔SETOM FLAG
03000
03100 CALL(TRYEASY,ARCO,ARCI)
03200 SKIPN FLAG↔GO L2
03300
03400 ;ADVANCE TO NEXT POLYGON OF THIS LEVEL.
03500 L3: LAC 1,IPG↔CCW 1,1
03600 CAME 1,PG0↔GO L1
03700 POP1J↔LIT
03800
03900 BEND;12/28/72-----------------------------------------------------
04000
04100 DECLARE{IV0,OV0}
04200 BRAD1: 3.0
04300 BRAD2: 1.8
00100 SUBR(NEXRAD)OV,IV-------------------------------------------------
00200 BEGIN NEXRAD;GET NEXT VERTEX WITH A RADIAL POINTER AFTER
00300 ;ADVANCING OV AND IV TO THEIR NEXT CCW ARC-VIC.
00400 ;BGB - 28 DECEMBER 1972.
00500 ACCUMULATORS{OV,IV,ARCO,ARCI,PG,R}
00600 LAC OV,ARG2↔LAC IV,ARG1
00700 PGON PG,IV↔SETZ R,
00800
00900 ;ADVANCE OV & IV CCW TO A VERTEX WITH AN ARC.
01000 ARC ARCO,OV↔JUMPN ARCO,.+5
01100 CCW OV,OV↔CAME OV,OV0↔GO .-4↔POP2J ;END OF OUTER POLY.
01200 ARC ARCI,IV↔JUMPN ARCI,.+5
01300 CCW IV,IV↔CAME IV,IV0↔GO .-4↔POP2J ;END OF INNER POLY.
01400
01500 ;ADVANCE IV CCW UNTIL EXO RADIAL.
01600 L1: EXO R,IV↔JUMPN R,L2
01700 CCW IV,IV↔CAME IV,IV0↔GO L1
01800
01900 ;ADVANCE OV CCW UNTIL ENDO RADIAL.
02000 L2: ENDO 1,OV↔JUMPN 1,[
02100 PGON 0,1↔CAME 0,PG↔GO .+1
02200 LAC IV,1↔GO L4]
02300 CAMN OV,R↔GO L4
02400 CCW OV,OV↔CAME OV,OV0↔GO L2↔POP2J
02500
02600 L4: AOS(P)↔POP2J
02700 BEND;12/30/72-----------------------------------------------------
00100 SUBR(TRYEASY)ARCO,ARCI-------------------------------------------
00200 BEGIN TRYEASY;TEST FOR EASY CASES AND CALL TRYHARD FOR HARD CASES.
00300 ;BGB - 28 DEC 1972 - ARC ARGUMENTS ALLEGED COINCIDENT & PARALLEL.
00400 ACCUMULATORS{ARCO,ARCI,ARCO2,ARCI2,R,C}
00500
00600 ;"UPPER" VERTICES OF THE PARALLELS.
00700 SETZM FLAG#
00800 LAC ARCO,ARG2
00900 LAC ARCI,ARG1
01000
01100 ;TEST FOR EASY CASE.
01200 CALL(DISTANCE,ARCO,ARCI)
01300 CAMG 1,BRAD1↔GO L2
01400
01500 ;TEST FOR "HIGHER" VERTEX - THE "LOWER" ONE IS BETWEEN ENDS.
01600 CCW ARCO2,ARCO
01700 ROW R,ARCI↔COL C,ARCI
01800 ROW 0,ARCO↔ROW 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
01900 CAMGE R,0↔GO L1↔CAMLE R,1↔GO L1
02000 COL 0,ARCO↔COL 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
02100 CAMGE C,0↔GO L1↔CAMLE C,1↔GO L1
02200
00100 ;ARC OUTER IS "HIGHER".
00200 L0: CCW ARCO,ARCO
00300 CALL(DISTANCE,ARCO,ARCI)
00400 CAMG 1,BRAD1↔GO L2↔CW ARCO,ARCO
00500 SETQ(ARCO,{TRYHARD,ARCI,ARCO})
00600 JUMPE ARCO,POP2J.↔GO L2
00700
00800 ;ARC INNER IS "HIGHER".
00900 L1: CCW ARCI,ARCI
01000 CALL(DISTANCE,ARCO,ARCI)
01100 CAMG 1,BRAD1↔GO L2↔CW ARCI,ARCI
01200 SETQ(ARCI,{TRYHARD,ARCO,ARCI})
01300 JUMPE ARCI,POP2J.↔GO L2
01400
01500 ;MAKE ARC RADIAL LINKS BETWEEN INNER AND OUTER ARCS.
01600 L2: EXO. ARCO,ARCI
01700 ENDO. ARCI,ARCO
01800 SKIPE FLAG↔POP2J ;EXIT SECOND TIME AROUND.
01900
02000 ;TEST EASY ON THE LOWER VERTICES OF THE PARALLELS.
02100 SETOM FLAG
02200 CCW ARCO2,ARCO
02300 CCW ARCI2,ARCI
02400 CALL(DISTANCE,ARCO2,ARCI2)
02500 CAMLE 1,BRAD1↔GO L3
02600 LAC ARCO,ARCO2↔LAC ARCI,ARCI2↔GO L2
02700
02800 ;TEST FOR "HIGHER" VERTEX - THE "LOWER" ONE IS BETWEEN ENDS.
02900 L3: ROW R,ARCI2↔COL C,ARCI2
03000 ROW 0,ARCO↔ROW 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
03100 CAMGE R,0↔GO L1↔CAMLE R,1↔GO[LAC ARCO,ARCO2↔GO L1]
03200 COL 0,ARCO↔COL 1,ARCO2↔CAMLE 0,1↔EXCH 0,1
03300 CAMGE C,0↔GO L1↔CAMLE C,1↔GO[LAC ARCO,ARCO2↔GO L1]
03400 LAC ARCI,ARCI2↔GO L0
03500 LIT
03600 BEND;1/5/73-------------------------------------------------------
00100 SUBR(DISTANCE)V1,V2-----------------------------------------------
00200 BEGIN DISTANCE
00300 DAC 2,TMP2↔DAC 3,TMP3
00400 LAC 3,ARG2↔ROW 0,3↔COL 1,3
00500 LAC 3,ARG1
00600 ROW 2,3↔SUB 0,2↔IMUL 0,0
00700 COL 2,3↔SUB 1,2↔IMUL 1,1
00800 ADD 0,1↔FSC 217↔CALL(SQRT,0)
00900 LAC 2,TMP2↔LAC 3,TMP3↔POP2J
01000 DECLARE{TMP2,TMP3}
01100 BEND;12/30/72-----------------------------------------------------
00100 SUBR(TRYHARD)V0,V1-------------------------------------------------
00200 BEGIN TRYHARD; TRY TO TIE V0 TO V1 BY SPLITTING THE ARC OF V1.
00300 ;BGB - 28 DECEMBER 1972.
00400 ACCUMULATORS{V0,V1,V2,V3,A,B,C,D,Q,X,Y}
00500
00600 ;PICKUP VERTICES.
00700 LAC V0,ARG2
00800 LAC V1,ARG1
00900 CCW V2,V1
01000
01100 ;PICKUP AND FLOAT LOCUS OF V0.
01200 COL X,V0↔FLO X,
01300 ROW Y,V0↔FLO Y,
01400
01500 ;COMPUTE NORMALIZED EDGE COEFFICIENTS OF EDGE V1-V2.
01600
01700 ROW A,V1↔FLO A, ; A ← Y1.
01800 COL B,V2↔FLO B, ; B ← X2.
01900 COL C,V1↔FLO C, ; C ← X1.
02000 ROW D,V2↔FLO D, ; D ← Y2.
02100
02200 LAC 1,B↔FMPR 1,A ; 1 ← X2*Y1.
02300 FSBR A,D↔FSBR B,C ; A ← Y1-Y2. B ← X2-X1.
02400 FMPR C,D↔FSBR C,1 ; C ← X1*Y2 - X2*Y1.
02500
02600 LAC 0,A↔FMPR 0,0
02700 LAC 1,B↔FMPR 1,1↔
02800 FADR 1,0↔CALL SQRT,1 ; Q ← SQRT(A*A + B*B).
02900
03000 FDVR A,1 ;DIVIDE BY Q.
03100 FDVR B,1
03200 FDVR C,1
03300
03400 ;COMPUTE DISTANCE FROM V0 TO THE EDGE.
03500 ; Q ← A*X0 + B*Y0 + C.
03600
03700 LAC Q,A↔FMP Q,X
03800 LAC 1,B↔FMP 1,Y
03900 FAD Q,1↔FAD Q,C
04000 MOVMS Q
04100
04200 ;IF DISTANCE GREATER THAN BUNDLE-RADIUS-2 THEN EXIT.
04300
04400 CAMLE Q,BRAD2↔GO LOSE
00100 ;COMPUTE LOCUS OF FOOT OF PERPENDICULAR DROPPED FROM V0.
00200
00300 ;Q ← 1/(A*A + B*B).
00400 ;D ← (B*X0 - A*Y0).
00500 ;X ← (B*D - A*C)*Q.
00600 ;Y ←-(A*D + B*C)*Q.
00700
00800 LAC 0,A↔FMP 0,0↔LAC 1,B↔FMP 1,1↔FAD 1,0↔SLACI Q,(1.0)↔FDVR Q,1
00900 FMP X,B↔FMP Y,A↔FSB X,Y↔LACN Y,X↔FMP X,B↔FMP Y,A
01000 LAC A↔FMP C↔FSBR X,↔FMPR X,Q↔FIX X,225000
01100 LAC B↔FMP C↔FSBR Y,↔FMPR Y,Q↔FIX Y,225000
01200
01300 ;MAKE CERTAIN THAT LOCUS OF V3 IS BETWEEN V1 AND V2.
01400
01500 ROW 0,V1↔ROW 1,V2
01600 CAMLE 0,1↔EXCH 0,1
01700 CAMGE Y,0↔GO LOSE
01800 CAMLE Y,1↔GO LOSE
01900
02000 COL 0,V1↔COL 1,V2
02100 CAMLE 0,1↔EXCH 0,1
02200 CAMGE X,0↔GO LOSE
02300 CAMLE X,1↔GO[
02400 LOSE: SETZ 1,↔POP2J]
02500
02600 ;SPLIT V1 AND TIE V3 TO V0.
02700
02800 SETQ(V3,{GETBLK})
02900 MARK V3,VBIT
03000 PGON 0,V1↔PGON. 0,V3
03100 CCW. V2,V3↔CW. V3,V2
03200 CCW. V3,V1↔CW. V1,V3
03300 ROW. Y,V3↔COL. X,V3
03400
03500 ;TRY TO FIND AN ARCLESS VERTEX NEAR V3.
03600
03700 ARC 1,V1
03800 ARC 2,V2
03900 CCW 1,1↔CAME 1,2↔GO[
04000 ROW 0,1↔SUB 0,Y↔MOVMS↔CAILE 200↔GO .-2
04100 COL 0,1↔SUB 0,X↔MOVMS↔CAILE 200↔GO .-2
04200 ARC. 1,V3↔ARC. V3,1↔GO .+1]
04300
04400 LAC 1,V3↔POP2J
04500 LIT
04600 BEND;12/30/72-----------------------------------------------------
00100 SUBR(MKWED1)IMAGE-------------------------------------------------
00200 BEGIN MKWED1;MAKE WINGED EDGES PHASE-1. ;HANG EDGE ON EVER VERTEX.
00300 ;BGB - 2 JANUARY 1973.
00400
00500 ACCUMULATORS{A,IM,LV,PG,F,E,V1,V2}
00600 EXTERN MKF,MKE
00700 SKIPN FLGKRK↔POP1J
00800
00900 ;GET ONE OF EVERYTHING.
01000 LAC IM,ARG1 ;IMAGE.
01100 HEAD LV,IM↔DAC LV,LV0# ;LEVEL.
01200 L1: HEAD PG,LV↔DAC PG,PG0# ;POLYGON.
01300 L2: ARC V1,PG↔DAC V1,V0# ;VERTEX.
01400 JUMPE V1,L4
01500 SETQ F,{MKF,IM} ;FACE.
01600 L3: SETQ E,{MKE,IM} ;EDGE.
01700
01800 ;PASTE IN ONE FACE AND TWO VERTICES.
01900 PFACE. F,E
02000 PED. E,V1
02100 CCW V2,V1
02200 PVT. V1,E
02300 NVT. V2,E
02400
02500 ;MAKE WINGS ON PVT.
02600 CW V1,V1↔PED A,V1
02700 JUMPE A,.+5
02800 NCCW. A,E↔PCW. A,E
02900 NCW. E,A↔PCCW. E,A
03000
03100 ;CLOSE POLYGON LOOP.
03200 LAC V1,V2
03300 CAME V2,V0↔GO L3
03400 CW V1,V2
03500 PED A,V1↔PED E,V2↔PED. E,F
03600 NCCW. A,E↔PCW. A,E
03700 NCW. E,A↔PCCW. E,A
03800
03900 ;NEXT POLYGON OF A LEVEL & NEXT LEVEL OF AN IMAGE.
04000 L4: CCW PG,PG↔CAME PG,PG0↔GO L2
04100 CCW LV,LV↔CAME LV,LV0↔GO L1
04200 POP1J
04300
04400 BEND;1/4/73-------------------------------------------------------
00100 SUBR(MKWED2)IMAGE-------------------------------------------------
00200 BEGIN MKWED2;MAKE WINGED EDGES PHASE-2.
00300 ;PLACE A TEMPORARY EDGE ON EVER RADIAL, THEN KILL THEM.
00400 ;BGB - 4 JANUARY 1973.
00500
00600 EXTERN MKFE,GLUEVV,KLVE,KLFE
00700 ACCUMULATORS{F1,F2,E,V1,V2}
00800 SKIPN FLGKRK↔POP1J
00900
01000 ;LOOP THRU THE POLYGONS OF THE IMAGE FROM INNERMOST TO OUTER ONES.
01100
01200 LAC 1,ARG1↔HEAD 1,1 ;IMAGE.
01300 DAC 1,LV0#↔CW 1,1 ;LEVEL.
01400 L1: DAC 1,LV#↔HEAD 1,1↔DAC 1,PG0# ;POLYGON.
01500 L2: DAC 1,PG#↔ARC 1,1↔DAC 1,V0# ;VERTEX.
01600
01700 L3: DAC 1,V#↔DAC 1,V1
01800 EXO V2,1↔JUMPE V2,L5 ;CHECK FOR RADIALS.
01900 PED E,V2↔PFACE F2,E ;EXO POLYGONS FACE.
02000 PED E,V1↔NFACE F1,E ;ENDO POLYGONS FACE.
02100
02200 ;CREATE WINGED EDGE AT RADIAL.
02300
02400 JUMPE F1,[
02500 SETQ E,{GLUEVV,F2,V2,F1,V1}↔GO L4]
02600 CAME F1,F2↔GO[FATAL(MKWED2, F1 ≠ F2.)]
02700 SETQ E,{MKFE,V1,F1,V2}
02800 L4: MARK E,TMPBIT
02900
03000
03100 ;NEXT POLYGON OF A LEVEL & NEXT LEVEL OF AN IMAGE.
03200
03300 L5: LAC 1,V ↔CCW 1,1↔CAME 1,V0↔GO L3
03400 LAC 1,PG↔CCW 1,1↔CAME 1,PG0↔GO L2
03500 LAC 1,LV↔CW 1,1↔CAME 1,LV0↔GO L1
03600
00100 ;KILL ALL THE EDGES THAT WERE JUST CREATED.
00200
00300 LAC 1,ARG1↔NED 1,1↔DAC 1,EDGE
00400 L6: LAC 1,EDGE#
00500 NED 2,1↔DAC 2,EDGE ;SAVE NEXT ONE.
00600 TEST 1,TMPBIT↔GO L7
00700 TEST 1,EBIT↔GO L7
00800 CALL(KLVE,1) ;KILL THIS ONE.
00900 GO L6
01000
01100 L7: GO KL2SID ;OLDE LISP LIKE EXIT.
01200
01300 BEND;1/4/73-------------------------------------------------------
00100 SUBR(KL2SID)IMAGE-------------------------------------------------
00200 BEGIN KL2SID; BGB - 5 JAN 1973.
00300
00400 ;KILL ALL THE 2 SIDED FACES OF AN IMAGE.
00500 ACCUMULATORS{E,F1,F2}
00600 LAC 1,ARG1↔PFACE F1,1↔GO L2+1
00700 L1: PFACE F2,F1
00800 DAC F2,FACE#
00900
01000 ;TEST PED FOR IDENTICAL WINGS IN THE GIVEN FACE.
01100 PED E,F1
01200 PFACE 0,E
01300 CAME 0,F1↔GO[
01400 NCW 0,E↔NCCW 1,E↔GO .+3]
01500 PCW 0,E↔PCCW 1,E
01600 CAME 0,1↔GO L2
01700 CALL(KLFE,E)
01800
01900 ;ADVANCE TO NEXT FACE - EXIT ON NON-FACE.
02000 L2: LAC F1,FACE
02100 TEST F1,FBIT
02200 POP1J
02300 GO L1
02400 LIT↔VAR
02500 BEND;1/5/73-------------------------------------------------------